Reprezentarea datelor sub forma de retea e o abordare diferita fata de modul clasic de reprezentare, cel tabelar. Acest format poate evidentia noi caracteristici ale datelor si imbunatesteste vizualizarea acestora intr-un mod semnificativ. Pentru a realiza o analiza originala, setul de date folosit reprezinta structura unei retele de trafic cu tigari de contrabanda din Romania, datele fiind extrase dintr-un dosar penal. Astfel, utilizand metode de graph mining vom realiza o analiza asupra structurii retelei, dar si asupra rolurilor individuale ale membrilor.
Datele au fost modelate folosind un obiect de tip reţea din librăria statnet. Legăturile dintre noduri au fost introduse folosind o lista de muchii, iar nodurile au următoarele atribute : nume, nume abreviat si rol.
netmat <- rbind(c(1,2),
c(1,3),
c(2,3),
c(1,4),
c(5,6),
c(7,8),
c(5,7),
c(5,8),
c(5,9),
c(6,7),
c(6,8),
c(6,9),
c(5,10),
c(6,10),
c(11,12),
c(11,13),
c(13,14),
c(14,19),
c(13,19),
c(14,1),
c(19,15),
c(19,16),
c(19,17),
c(19,18),
c(12,15),
c(12,16),
c(12,17),
c(12,18),
c(20,8),
c(20,9),
c(21,8),
c(21,9),
c(3,8),
c(3,9),
c(1,8),
c(1,9))
net <- network(netmat, matrix.type="edgelist")Pentru a ne asigura ca graful este unul ne-orientat, simetrizam matricea de adiacenta asociata primului obiect, si generam un nou obiect, pentru a lucra cu un graf ne-orientat. Acest lucru se datoreaza faptului ca relatiile sociale in cadrul acestei retele nu pot fi uni-directionale.
netmatsym <- symmetrize(as.sociomatrix(net), rule ="weak")
netsym <- network(netmatsym, matrix.type="adjacency")
network.vertex.names(netsym) <- c("B***cu L***na",
"B***cu An***us",
"B**scu C***nel",
"B**hiu G***ge",
"M**tu M**na",
"Ma**u I***he",
"T**a F**p",
"T**a G***ghe",
"S**m An**la",
"G**ca G****ghe",
"C**u I**n",
"M***u L**do",
"D**a D**a",
"D**a C**l",
"N**cu P**u",
"N**se T**er",
"S***an C***tin",
"O***u A**ei",
"D**a I***l",
"P**ci V***e",
"D***mir R**a")
set.vertex.attribute(netsym, "role", c("C",
"C",
"C",
"CR",
"C",
"C",
"CT",
"CT",
"CT",
"C",
"C",
"A",
"A",
"C",
"C",
"C",
"C",
"C",
"CT",
"D",
"D"))
# C : Comerciant, CR : Cartita, CT: contrabandist, A: aducator clienti, D: depozitare
set.vertex.attribute(netsym, "abrev_name", c("BL",
"BA",
"BC",
"BG",
"MM",
"MI",
"TF",
"TG",
"SA",
"GG",
"CI",
"ML",
"DD",
"DC",
"NP",
"NT",
"SC",
"OA",
"DI",
"PV",
"DR"))Extragerea atributelor retelei in variabile separate, pentru a fi folosite ulterior in operatiile de plotare.
netsym %v% "alldeg" <- degree(netsym)
namelab <- get.vertex.attribute(netsym, "vertex.names")
rolelab <- get.vertex.attribute(netsym, "role")
abrevnamelab <-get.vertex.attribute(netsym, "abrev_name")
my_pal <- brewer.pal(5,"Dark2")
rolecat <- as.factor(get.vertex.attribute(netsym,"role"))Un prim plot al retelei pentru a vizualiza structura acesteia, si impartirea membrilor pe roluri.
plot(netsym,
main = "Infractional network",
usearrows=FALSE,
mode="fruchtermanreingold",
vertex.col = my_pal[rolecat],
label=rolelab,
displaylabels=T,
vertex.cex = 1.5)O prima analiza asupra retelei este realizarea rezumatului in 5 puncte. Functiile prezente in libraria statnet faciliteaza realizarea acesteia. Analizand aceste valori, putem avea o prima impresie despre structura retelei si despre modul de organizarea a acesteia.
## [1] "BASIC CHARACTERISTICS"
## Network attributes:
## vertices = 21
## directed = TRUE
## hyper = FALSE
## loops = FALSE
## multiple = FALSE
## bipartite = FALSE
## total edges = 72
## missing edges = 0
## non-missing edges = 72
## density = 0.1714286
##
## Vertex attributes:
##
## abrev_name:
## character valued attribute
## attribute summary:
## the 10 most common values are:
## BA BC BG BL CI DC DD DI DR GG
## 1 1 1 1 1 1 1 1 1 1
##
## alldeg:
## numeric valued attribute
## attribute summary:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 2.000 4.000 6.000 6.857 10.000 14.000
##
## role:
## character valued attribute
## attribute summary:
## A C CR CT D
## 2 12 1 4 2
## vertex.names:
## character valued attribute
## 21 valid vertex names
##
## No edge attributes
## [1] "Size:"
## [1] 21
## [1] "Density:"
## [1] 0.1714286
## [1] "Components:"
## [1] 1
## [1] "Diameter:"
## [1] 7
## [1] "Transitivity:"
## [1] 0.25
Folosind atributele definite în momentul creării, putem filtra reţeua astfel încat putem evidenţia importanţa unui anume rol. Spre exemplu, dacă am păstra în reţea doar Comercianţii, putem observa că aceştia sunt în mare partea izolaţi, distrugând aspectul de reţea compactă. Acest lucru evidenţiază rolul contrabandiştilor în reţea, aceştia asigurând practic conexitatea reţelei.
print("Filtering networks")
print(get.vertex.attribute(netsym, "role"))
comercianti <- get.inducedSubgraph(netsym, which (netsym %v% "role"=="C"))
gplot(comercianti,displaylabels=TRUE, main="Comercianti")delete.vertices(comercianti, isolates(comercianti))
gplot(comercianti, displaylabels = TRUE, main="Grupuri de comercianti")gplot(netsym,gmode="graph",edge.col="grey75",displaylabels=T,
vertex.cex=1.5,mode='circle',main="circle") ## Eigen
gplot(netsym,gmode="graph",edge.col="grey75",displaylabels=T,
vertex.cex=1.5,mode='eigen',main="eigen")gplot(netsym,gmode="graph",edge.col="grey75",displaylabels=T,
vertex.cex=1.5,mode='random',main="random")gplot(netsym,gmode="graph",edge.col="grey75",displaylabels=T,
vertex.cex=1.5,mode='spring',main="spring")##
## Attaching package: 'igraph'
## The following objects are masked from 'package:sna':
##
## betweenness, bonpow, closeness, components, degree, dyad.census,
## evcent, hierarchy, is.connected, neighborhood, triad.census
## The following objects are masked from 'package:network':
##
## %c%, %s%, add.edges, add.vertices, delete.edges, delete.vertices,
## get.edge.attribute, get.edges, get.vertex.attribute, is.bipartite,
## is.directed, list.edge.attributes, list.vertex.attributes,
## set.edge.attribute, set.vertex.attribute
## The following objects are masked from 'package:stats':
##
## decompose, spectrum
## The following object is masked from 'package:base':
##
## union
sidenum <- 3:7
rolecat <- as.factor(get.vertex.attribute(asIgraph(netsym),"role"))
plot(netsym,usearrows=FALSE,vertex.cex=4, main="Different node type",
displaylabels=F,vertex.sides=sidenum[rolecat])n_edge <- network.edgecount(netsym)
linecol_pal <- c("blue","red","green")
edge_cat <- sample(1:3,n_edge,replace=T)
plot(netsym,vertex.cex=1.5,vertex.col="grey25", main="Edge coloring example",
edge.col=linecol_pal[edge_cat],edge.lwd=2)n_edge <- network.edgecount(netsym)
edge_cat <- sample(1:3,n_edge,replace=T)
line_pal <- c(2,3,4)
gplot(netsym,vertex.cex=0.8,gmode="graph", main="Different edge type",
vertex.col="gray50",edge.lwd=1.5,
edge.lty=line_pal[edge_cat])my_pal <- brewer.pal(5,"Dark2")
rolecat <- as.factor(get.vertex.attribute(asIgraph(netsym),"role"))
plot(netsym,
main = "Infractional network",
usearrows=FALSE,
mode="fruchtermanreingold",
vertex.col = my_pal[rolecat],
label=abrevnamelab,
displaylabels=T,
vertex.cex = 1.5)
legend("bottomleft",legend=c("Aducator clienti","Comerciant","Cartita","Contrabandist","Depozitare"),
col=my_pal,pch=19,pt.cex=1.5,bty="n",
title="Criminal Role")inetsym <- asIgraph(netsym)
Coord <- tkplot(inetsym, vertex.size=3,
vertex.label=V(inetsym)$role,
vertex.color="darkgreen")
MCoords <- tkplot.getcoords(Coord)
plot(inetsym, layout=MCoords, vertex.size=5,main="Interactive tkplot",
vertex.label=NA, vertex.color="lightblue")# NetworkD3
inetsym_edge <- get.edgelist(inetsym)
inetsym_edge <- inetsym_edge - 1
inetsym_edge <- data.frame(inetsym_edge)
print(V(inetsym)$role)## [1] "C" "C" "C" "CR" "C" "C" "CT" "CT" "CT" "C" "C" "A" "A" "C" "C"
## [16] "C" "C" "C" "CT" "D" "D"
inetsym_nodes <- data.frame(NodeID=as.numeric(V(inetsym)-1),
Group=V(inetsym)$role,
Nodesize=(degree(inetsym)))
net_D3 <- forceNetwork(Links = inetsym_edge, Nodes = inetsym_nodes,
Source = "X1", Target = "X2",
NodeID = "NodeID",Nodesize = "Nodesize",
radiusCalculation="Math.sqrt(d.nodesize)*3",
Group = "Group", opacity = 0.8,
legend=TRUE)
saveNetwork(net_D3,file = 'Net_test2.html',
selfcontained=TRUE)
#Visnetwork
library(visNetwork)
inetsym_edge <- get.edgelist(inetsym)
inetsym_edge <- data.frame(from = inetsym_edge[,1],
to = inetsym_edge[,2])
inetsym_nodes <- data.frame(id = as.numeric(V(inetsym)))
visNetwork(inetsym_nodes, inetsym_edge, width = "100%")## Warning in visNetwork(inetsym_nodes, inetsym_edge, width = "100%", legend =
## TRUE): 'legend' and 'legend.width' are deprecated (visNetwork >= 0.1.2). Please
## now prefer use visLegend function.
net <- visOptions(net,highlightNearest = TRUE)
net <- visInteraction(net,navigationButtons = TRUE)
library(htmlwidgets)##
## Attaching package: 'htmlwidgets'
## The following object is masked from 'package:networkD3':
##
## JS
## ========================================
## circlize version 0.4.11
## CRAN page: https://cran.r-project.org/package=circlize
## Github page: https://github.com/jokergoo/circlize
## Documentation: https://jokergoo.github.io/circlize_book/book/
##
## If you use it in published research, please cite:
## Gu, Z. circlize implements and enhances circular visualization
## in R. Bioinformatics 2014.
##
## This message can be suppressed by:
## suppressPackageStartupMessages(library(circlize))
## ========================================
##
## Attaching package: 'circlize'
## The following object is masked from 'package:igraph':
##
## degree
## The following object is masked from 'package:sna':
##
## degree
##
## statnet: version 2019.6, created on 2019-06-13
## Copyright (c) 2019, Mark S. Handcock, University of California -- Los Angeles
## David R. Hunter, Penn State University
## Carter T. Butts, University of California -- Irvine
## Steven M. Goodreau, University of Washington
## Pavel N. Krivitsky, University of Wollongong
## Skye Bender-deMoll
## Martina Morris, University of Washington
## Based on "statnet" project software (statnet.org).
## For license and citation information see statnet.org/attribution
## or type citation("statnet").
## Warning in as.matrix.network.adjacency(x, attrname = attrname, expand.bipartite
## = expand.bipartite, : There is no edge attribute named passes
detach("package:networkD3", unload=TRUE)
detach("package:igraph", unload=TRUE)
print("CENTRALITY DEGREES")## [1] "CENTRALITY DEGREES"
## [1] 6 2 4 1 5 5 3 7 6 2 2 5 3 3 2 2 2 2 6 2 2
## [1] 0.4761905 0.3333333 0.3846154 0.3278689 0.3278689 0.3278689 0.3174603
## [8] 0.4166667 0.4081633 0.2531646 0.2941176 0.2564103 0.3636364 0.4444444
## [15] 0.2941176 0.2941176 0.2941176 0.2941176 0.3846154 0.3076923 0.3076923
## [1] 113.1666667 0.0000000 4.1666667 0.0000000 9.6666667 9.6666667
## [7] 0.0000000 51.0000000 36.0000000 0.0000000 3.6000000 7.0000000
## [13] 16.6000000 96.0000000 2.8500000 2.8500000 2.8500000 2.8500000
## [19] 69.4000000 0.1666667 0.1666667
#Cutpoints
cpnet <- cutpoints(netsym,mode="graph",
return.indicator=TRUE)
gplot(netsym,gmode="graph",vertex.col=cpnet+2,coord=MCoords,
jitter=FALSE,displaylabels=TRUE)#Bridges
bridges <- function(dat,mode="graph",
connected=c("strong", "weak")) {
e_cnt <- network.edgecount(dat)
if (mode == "graph") {
cmp_cnt <- components(dat)
b_vec <- rep(FALSE,e_cnt)
for(i in 1:e_cnt){
dat2 <- dat
delete.edges(dat2,i)
b_vec[i] <- (components(dat2) != cmp_cnt)
}
}
else {
cmp_cnt <- components(dat,connected=connected)
b_vec <- rep(FALSE,e_cnt)
for(i in 1:e_cnt){
dat2 <- dat
delete.edges(dat2,i)
b_vec[i] <- (components(dat2) != cmp_cnt)
}
}
return(b_vec)
}
bridges(netsym)## [1] FALSE FALSE TRUE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE
## [13] TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [25] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [37] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [49] FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [61] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
colors <- c("blue", "red")
# Determining the centre nodes using the degree
deg <- degree(netsym, gmode="graph")
plot(netsym,
usearrows=FALSE,
vertex.col = colors[(deg >= 5) + 1],
label = netsym %v% "abrev_name",
displaylabels=T,
vertex.cex = deg/2)# Determining the centre nodes using the closeness function
cls <- closeness(netsym, gmode="graph")
plot(netsym,
usearrows=FALSE,
vertex.col = colors[(cls >= 0.33) + 1],
label = netsym %v% "abrev_name",
displaylabels=T,
vertex.cex = cls*10)# Determining the centre nodes using the betweenness function
bet <- betweenness(netsym, gmode="graph")
plot(netsym,
usearrows=FALSE,
vertex.col = colors[(bet >= 90) + 1],
label = netsym %v% "abrev_name",
displaylabels=T,
vertex.cex = sqrt(bet+1))# Computing the level of correlation between multiple centrality measures
df.prom <- data.frame(
deg = degree(netsym),
cls = closeness(netsym),
btw = betweenness(netsym),
evc = evcent(netsym),
inf = infocent(netsym),
flb = flowbet(netsym)
)
cor(df.prom)## deg cls btw evc inf flb
## deg 1.0000000 0.6013689 0.5917256 0.6360877 0.7918289 0.5708101
## cls 0.6013689 1.0000000 0.8545112 0.4791390 0.8593100 0.8230555
## btw 0.5917256 0.8545112 1.0000000 0.2297788 0.7352932 0.9357088
## evc 0.6360877 0.4791390 0.2297788 1.0000000 0.7469055 0.3381616
## inf 0.7918289 0.8593100 0.7352932 0.7469055 1.0000000 0.7994418
## flb 0.5708101 0.8230555 0.9357088 0.3381616 0.7994418 1.0000000
# Tabular visualization for multiple centrality measures
# Defining a data frame in which is computed the centrality for all nodes using
# multiple methods
df.prom2 <- data.frame(
name = network.vertex.names(netsym),
degree = degree(netsym, gmode="graph"),
closeness = closeness(netsym, gmode="graph"),
betweenness = betweenness(netsym, gmode="graph"))
df.promsort <- df.prom2[order(-df.prom2$degree),]
cd <- centralization(netsym,degree)
cc <- centralization(netsym,closeness)
cb <- centralization(netsym,betweenness)
df.promsort <- rbind(df.promsort,data.frame(
name = "Centralization level",
degree = cd,
closeness = cc,
betweenness = cb
))
df.promsort## name degree closeness betweenness
## 8 T**a G***ghe 7.0000000 0.4166667 51.0000000
## 1 B***cu L***na 6.0000000 0.4761905 113.1666667
## 9 S**m An**la 6.0000000 0.4081633 36.0000000
## 19 D**a I***l 6.0000000 0.3846154 69.4000000
## 5 M**tu M**na 5.0000000 0.3278689 9.6666667
## 6 Ma**u I***he 5.0000000 0.3278689 9.6666667
## 12 M***u L**do 5.0000000 0.2564103 7.0000000
## 3 B**scu C***nel 4.0000000 0.3846154 4.1666667
## 7 T**a F**p 3.0000000 0.3174603 0.0000000
## 13 D**a D**a 3.0000000 0.3636364 16.6000000
## 14 D**a C**l 3.0000000 0.4444444 96.0000000
## 2 B***cu An***us 2.0000000 0.3333333 0.0000000
## 10 G**ca G****ghe 2.0000000 0.2531646 0.0000000
## 11 C**u I**n 2.0000000 0.2941176 3.6000000
## 15 N**cu P**u 2.0000000 0.2941176 2.8500000
## 16 N**se T**er 2.0000000 0.2941176 2.8500000
## 17 S***an C***tin 2.0000000 0.2941176 2.8500000
## 18 O***u A**ei 2.0000000 0.2941176 2.8500000
## 20 P**ci V***e 2.0000000 0.3076923 0.1666667
## 21 D***mir R**a 2.0000000 0.3076923 0.1666667
## 4 B**hiu G***ge 1.0000000 0.3278689 0.0000000
## 110 Centralization level 0.1973684 0.1518153 0.5127632
# Cutpoints are nodes that if removed will affect the conectivity of the network
# In the graphic below, it is displayed with green the cutpoint nodes.
cpnet <- cutpoints(netsym,mode="graph",return.indicator=TRUE)
gplot(netsym,gmode="graph",vertex.cex=cpnet+2,vertex.col=cpnet+2,jitter=FALSE,
displaylabels=TRUE,label=netsym %v% "abrev_name")# Bridges are edges that if removed will affect the conectivity of the network
# In the graphic below it is displayed with green the edges that are bridges.
bridges <- function(dat,mode="graph",connected=c("strong", "weak")) {
e_cnt <- network.edgecount(dat)
if (mode == "graph") {
cmp_cnt <- components(dat)
b_vec <- rep(FALSE,e_cnt)
for(i in 1:e_cnt){
dat2 <- dat
delete.edges(dat2,i)
b_vec[i] <- (components(dat2) != cmp_cnt)
}
}
else {
cmp_cnt <- components(dat,connected=connected)
b_vec <- rep(FALSE,e_cnt)
for(i in 1:e_cnt){
dat2 <- dat
delete.edges(dat2,i)
b_vec[i] <- (components(dat2,connected=connected) != cmp_cnt)
}
}
return (b_vec)
}
bridges(netsym)## [1] FALSE FALSE TRUE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE
## [13] TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [25] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [37] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [49] FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
## [61] FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE
brnet <- bridges(netsym)
gplot(netsym,gmode="graph",vertex.col="red",edge.col=brnet+2,jitter=FALSE,
displaylabels=TRUE,label=netsym %v% "abrev_name",edge.lwd=3*brnet+2)Acest capitol este dedicat descoperirii subgrupurilor dintr-o retea. Acest tip de analiza are un rol foarte important, deoarece s-a observat ca in majoritatea retelelor sociale, indiferent de dimensiunea acestora, exista o tendinta de separare a actantilor in subgrupuri puternic interconectate, iar ale caror legaturi cu membrii din afara subgrupului sunt intr-un numar relativ mic. Desi pentru o retea de dimensiuni reduse nu este necesara o analiza amanuntita pentru a descoperi grupurile din cadrul unei retele, pentru dimensiuni considerabile ale retelelor, existenta subgrupurilor nu mai este atat de evidenta, iar complexitatea metodelor necesare trebuie sa fie mai mare.
Cea mai intuitiva abordare a subgrupurilor a fost de a le lega de notiunea de coeziune sociala, adica sunt considerate ca fiind subgrupuri submultimile de noduri ce contin cat mai multe conexiuni directe. In cazul retelelor care contin o componenta ce ofera informatii despre puterea unei legaturi (spre exemplu, intr-o retea de socializare putem privi relatiile de pretenie ca avand un grad determinat de frecventa de interactiune: zilnic, saptamanal, lunar, ocazional), aceasta poate fi integrata in determinarea subgrupurilor tinand cont de faptul ca legaturile mai slabe sunt folosite mai probabil pentru a conecta doua subgrupuri diferite decat pentru a conecta doua noduri din cadrul aceluiasi subgrup.
O prima abordare bazata pe notiunea de coeziune sociala, a fost de a considera subgrup doar submultimile care au conexiune intre oricare doua noduri. Mai exact, aceasta separare reprezinta de fapt, extragerea de subgrafuri complete din reteaua initiala. Un subgrup determinat prin aceasta metoda poarta denumirea de “clique”. Mai jos sunt utilizate cateva metode pentru determinarea acestora in reteaua de traficanti. Pentru a intelege mai bine rezultatele urmatoare sunt necesare doua observatii: * putem sa consideram o dimensiune minima pentru un subgrup, de regula 3 noduri, deoarece subgrupurile de dimensiune 1 si 2 nu sunt relevante (orice nod poate fi considerat un subgrup si orice doua noduri conectate pot fi considerate un subgrup). * subgrupurile formate din patru noduri cuprind (sub forma de subgraf) subgrupuri formate din trei noduri, deci are sens sa introducem notiunea de “clique” maximal (care nu mai poate fi extins prin adaugarea altor noduri).
## [1] 4
## [[1]]
## + 3/21 vertices, named, from 4be514f:
## [1] MI TF TG
##
## [[2]]
## + 3/21 vertices, named, from 4be514f:
## [1] DD DC DI
##
## [[3]]
## + 3/21 vertices, named, from 4be514f:
## [1] BL BA BC
##
## [[4]]
## + 3/21 vertices, named, from 4be514f:
## [1] BL BC SA
##
## [[5]]
## + 3/21 vertices, named, from 4be514f:
## [1] BL BC TG
##
## [[6]]
## + 3/21 vertices, named, from 4be514f:
## [1] MM MI TF
##
## [[7]]
## + 4/21 vertices, named, from 4be514f:
## [1] MM MI TF TG
##
## [[8]]
## + 3/21 vertices, named, from 4be514f:
## [1] MM MI GG
##
## [[9]]
## + 3/21 vertices, named, from 4be514f:
## [1] MM MI SA
##
## [[10]]
## + 3/21 vertices, named, from 4be514f:
## [1] MM MI TG
##
## [[11]]
## + 3/21 vertices, named, from 4be514f:
## [1] MM TF TG
## [[1]]
## + 3/21 vertices, named, from 4be514f:
## [1] BA BL BC
##
## [[2]]
## + 3/21 vertices, named, from 4be514f:
## [1] DC DD DI
##
## [[3]]
## + 3/21 vertices, named, from 4be514f:
## [1] GG MM MI
##
## [[4]]
## + 4/21 vertices, named, from 4be514f:
## [1] TF MM TG MI
##
## [[5]]
## + 3/21 vertices, named, from 4be514f:
## [1] MM MI SA
##
## [[6]]
## + 3/21 vertices, named, from 4be514f:
## [1] BC BL TG
##
## [[7]]
## + 3/21 vertices, named, from 4be514f:
## [1] BC BL SA
## [[1]]
## + 4/21 vertices, named, from 4be514f:
## [1] TG MM MI TF
In majoritatea retelelor, constrangerea de a avea legaturi intre oricare doua noduri dintr-un subgrup este prea puternica, fapt ce conduce la determinarea unor subgrupuri de dimensiuni reduse, chiar si in cadrul retelelor foarte mari. Astfel, a fost introdusa notiunea de “k-Core”, care relaxeaxa cerinta legata de numarul de legaturi pe care trebuie sa le aiba un nod cu celelalte noduri din subgrup. Concret, daca extragem un k-Core, toate nodurile trebuie sa aiba gradul cel putin egal cu k. O observatie importanta este ca o analiza “1-Core” este echivalenta cu determinarea componentelor conexe din cadrul unui graf. In cele ce urmeaza sunt analizate componentele “k-Core” din cadrul retelei de traficanti.
## For each k, determine the number of nodes that are part of a k-Core (but not a (k+1)-Core, k is maximum)
coreness <- graph.coreness(inetsym)
table(coreness)## coreness
## 1 2 3
## 1 13 7
# Plot the network, with each node having its maximum k on it
maxCoreness <- max(coreness)
colors <- rainbow(maxCoreness)
plot(inetsym,vertex.label=coreness,vertex.color=colors[coreness],layout=layout_with_fr)# Gradually remove the nodes that are only part of 1-Cores and 2-Cores
i1_3 <- inetsym
i2_3 <- induced.subgraph(inetsym, vids=which(coreness > 1))
i3_3 <- induced.subgraph(inetsym, vids=which(coreness > 2))
lay <- layout.fruchterman.reingold(inetsym)
op <- par(mfrow=c(1,3),mar = c(3,0,2,0))
plot(i1_3,layout=lay,vertex.label=coreness,vertex.color=colors[coreness],main="All k-cores")
plot(i2_3,layout=lay[which(coreness > 1),],vertex.label=coreness[which(coreness > 1)],vertex.color=colors[coreness[which(coreness > 1)]],main="k-cores 2-3")
plot(i3_3,layout=lay[which(coreness > 2),],vertex.label=coreness[which(coreness > 2)],vertex.color=colors[coreness[which(coreness > 2)]],main="k-cores 3")Pentru a putea realiza o comparatie intre mai multe moduri de a imparti o retea in subgrupuri, este necesara existenta unei metode de a stabili cat de potrivita este o impartire in subgrupuri. Astfel, a fost introdusa notiunea de modularitate. Modularitate este o statistica ce poate fi calculata efectuand scaderea dintre probabilitatea ca alegand o legatura din retea aceasta sa fie intre noduri din acelasi subgrup si aceeasi probabilitate calculata intr-o retea formata din aceleasi noduri, dar in care muchiile sunt distribuite in mod aleator (numarul de muchii din reteaua initiala este conservat). Prin urmare, vom incerca sa realizam o impartire in subgrupuri a retelei de traficanti folosind drept criteriu rolul fiecarui actant. Se poate observa la sfarsit ca acest criteriu nu este cel mai potrivit tinand cont de faptul ca modularitatea obtinuta este negativa.
## Computing the modularity of the clusterization method
V(inetsym)$group <- strtoi(V(inetsym)$role)
modularity(inetsym, V(inetsym)$group)## [1] -0.1508488
## Visualizing the network by emphasizing the role of each node
colors <- brewer.pal(5,"Dark2")
V(inetsym)$color <- colors[strtoi(V(inetsym)$role)]
op <- par(mfrow=c(1,1))
plot(inetsym,vertex.color=V(inetsym)$color,vertex.size=20)Pana in acest moment, metodele prezentate (“clique” si “k-Core”) exploreaza doar legaturile interne din cadrul unui subgrup, nefiind analizate tipare ale legaturilor catre exteriorul unui subgrup. De aceea, au fost dezvoltati diversi algoritmi care sa exploreze aceasta zona. In cele ce urmeaza vom folosi mai multi algoritmi de acest tip, denumiti “Community Detection”, pentru a analiza rezultatele acestora pe reteaua de traficanti, precum si pentru a compara intre ele aceste rezultate (intre unii algoritmi se poate observa o similitudine in rezultate, data si de constructia similara a acestora).
## Applying multiple community detection algorithms
cw <- cluster_walktrap(inetsym)
modularity(cw); membership(cw)## [1] 0.4903549
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 3 3 3 3 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 2 2
## [1] 0.4903549
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 1 1 1 1 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 2 2
## [1] 0.4903549
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 2 2 2 2 1 1 1 1 1 1 3 3 3 3 3 3 3 3 3 1 1
## [1] 0.4695216
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 1 1 1 1 3 3 3 3 1 3 2 2 2 2 2 2 2 2 2 1 1
## [1] 0.4756944
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 1 1 1 1 2 2 2 1 1 2 3 3 3 3 3 3 3 3 3 1 1
## [1] 0.464892
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 1 1 1 1 3 3 3 3 1 3 2 2 2 2 2 2 2 2 2 3 3
## [1] 0.4903549
## BL BA BC BG MM MI TF TG SA GG CI ML DD DC NP NT SC OA DI PV DR
## 3 3 3 3 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 1 1
##
## 1 2 3
## 1 2 0 0
## 2 6 3 3
## 3 0 0 1
## 4 1 3 0
## 5 0 2 0
## [1] 0.02816901
## [1] 1
## [1] 1
## [1] 0.7075812
# Visualizing the splitting made by each method
op <- par(mfrow=c(3,2),mar=c(3,0,2,0))
plot(ceb, inetsym,vertex.label=NA,main="Edge Betweenness")
plot(cfg, inetsym,vertex.label=NA,main="Fastgreedy")
plot(clp, inetsym,vertex.label=NA,main="Label Propagation")
plot(cle, inetsym,vertex.label=NA,main="Leading Eigenvector")
plot(cs, inetsym,vertex.label=NA,main="Spinglass")
plot(cw, inetsym,vertex.label=NA,main="Walktrap")Conceptele din acest capitol nu pot fi ilustrate pe reteaua traficantilor, de aceea exemple prezentate utilizeaza un set de date ilustrat in cartea din bibliografie. Aceste notiuni sunt aplicate pe grafuri in care legaturile dintre actanti nu sunt directe, ci sunt date de faptul ca cele doua persoane sunt parte al aceluiasi grup (de exemplu: clasa, departament, oras).
Un exemplu foarte uzual pentru acest tip de retele sunt cele denumite “2-Mode Networks”. Acestea se remarca prin faptul ca nodurilor din cadrul lor reprezinta doua clase diferite. Mai jos este prezentata o retea formata din elevi si clase, fiind realizate legaturi doar intre obiecte de tipuri diferite.
C1 <- c(1,1,1,0,0,0)
C2 <- c(0,1,1,1,0,0)
C3 <- c(0,0,1,1,1,0)
C4 <- c(0,0,0,0,1,1)
aff.df <- data.frame(C1,C2,C3,C4)
row.names(aff.df) <- c("S1","S2","S3","S4","S5","S6")
aff.df## C1 C2 C3 C4
## S1 1 0 0 0
## S2 1 1 0 0
## S3 1 1 1 0
## S4 0 1 1 0
## S5 0 0 1 1
## S6 0 0 0 1
O consecinta a faptului ca avem doua tipuri de noduri, iar legaturile se realizeaza doar intre tipuri diferite de noduri, este ca graful obtinut este bipartit, dupa cum se poate observa si din graficul urmator.
## Plotting the affiliation network to illustrate the bipartite property
bn <- graph.incidence(aff.df)
plt.x <- c(rep(2,6),rep(4,4))
plt.y <- c(7:2,6:3)
lay <- as.matrix(cbind(plt.x,plt.y))
shapes <- c("circle","square")
colors <- c("blue","red")
plot(bn,vertex.color=colors[V(bn)$type+1],vertex.shape=shapes[V(bn)$type+1],
vertex.size=10,vertex.label.degree=-pi/2,vertex.label.dist=1.2,
vertex.label.cex=0.9,layout=lay)Similar cu celelalte retele, si “affiliation networks” pot fi create atat pornind de la o matrice de incidenta, cat si de la o lista de muchii. In cele ce urmeaza sunt prezentate exemple pentru ambele metode.
## IGRAPH c6c1801 UN-B 10 11 --
## + attr: type (v/l), name (v/c)
## + edges from c6c1801 (vertex names):
## [1] S1--C1 S2--C1 S2--C2 S3--C1 S3--C2 S3--C3 S4--C2 S4--C3 S5--C3 S5--C4
## [11] S6--C4
## C1 C2 C3 C4
## S1 1 0 0 0
## S2 1 1 0 0
## S3 1 1 1 0
## S4 0 1 1 0
## S5 0 0 1 1
## S6 0 0 0 1
## [1] FALSE FALSE FALSE FALSE FALSE FALSE TRUE TRUE TRUE TRUE
## [1] "S1" "S2" "S3" "S4" "S5" "S6" "C1" "C2" "C3" "C4"
## Creating Affiliation Networks from Edge Lists
el.df <- data.frame(rbind(c("S1","C1"),
c("S2","C1"),
c("S2","C2"),
c("S3","C1"),
c("S3","C2"),
c("S3","C3"),
c("S4","C2"),
c("S4","C3"),
c("S5","C3"),
c("S5","C4"),
c("S6","C4")))
bn2 <- graph.data.frame(el.df,directed=FALSE)
V(bn2)$type <- V(bn2)$name %in% el.df[,1]
bn2## IGRAPH 53ca3cc UN-B 10 11 --
## + attr: name (v/c), type (v/l)
## + edges from 53ca3cc (vertex names):
## [1] S1--C1 S2--C1 S2--C2 S3--C1 S3--C2 S3--C3 S4--C2 S4--C3 S5--C3 S5--C4
## [11] S6--C4
## [1] TRUE
O analiza interesanta ce poate fi realizata pe un “affiliation network”, este un studiu pe componente ce poate fi realizat cu ajutorul proiectiilor. O proiectie permite analiza doar unuia dintre cele doua tipuri de noduri prezente intr-o retea “2-Mode”. Legaturile dintre noduri in cadrul unei proiectii sunt date de legaturile indirecte din reteaua initiala (daca doi studenti stuadiaza in aceeasi clasa, atunci intre acestia va exista o legatura directa in proiectie). In cele ce urmeaza vom ilustra proiectiile pe reteaua de studenti si clase.
## Making the projections on both components
bn.pr <- bipartite.projection(bn)
bn.student <- bn.pr$proj1
bn.class <- bn.pr$proj2
get.adjacency(bn.student,sparse=FALSE,attr="weight")## S1 S2 S3 S4 S5 S6
## S1 0 1 1 0 0 0
## S2 1 0 2 1 0 0
## S3 1 2 0 2 1 0
## S4 0 1 2 0 1 0
## S5 0 0 1 1 0 1
## S6 0 0 0 0 1 0
## C1 C2 C3 C4
## C1 0 2 1 0
## C2 2 0 2 0
## C3 1 2 0 1
## C4 0 0 1 0
## Plotting the projections
shapes <- c("circle","square")
colors <- c("blue","red")
op <- par(mfrow=c(1,2))
plot(bn.student,vertex.color="blue",vertex.shape="circle",main="Students",
edge.width=E(bn.student)$weight*2,vertex.size=15,vertex.label.degree=-pi/2,
vertex.label.dist=1.2,vertex.label.cex=1)
plot(bn.class,vertex.color="red",vertex.shape="square",main="Classes",
edge.width=E(bn.student)$weight*2,vertex.size=15,vertex.label.degree=-pi/2,
vertex.label.dist=1.2,vertex.label.cex=1)In cele ce urmeaza, vom prezenta analiza unui set de date de tipul “2-Mode” ce cuprinde filme din perioada 1999-2014, precum si actorii care au avut cele mai importante roluri in aceste filme.
## IGRAPH 9cdab39 UN-B 1365 1600 --
## + attr: name (v/c), type (v/l), year (v/n), IMDBrating (v/n),
## | MPAArating (v/c)
## + edges from 9cdab39 (vertex names):
## [1] Inception --Leonardo DiCaprio
## [2] Inception --Joseph Gordon-Levitt
## [3] Inception --Ellen Page
## [4] Inception --Tom Hardy
## [5] Inception --Ken Watanabe
## [6] Inception --Dileep Rao
## [7] Inception --Cillian Murphy
## + ... omitted several edges
## [1] "Inception"
## [2] "Alice in Wonderland"
## [3] "Kick-Ass"
## [4] "Toy Story 3"
## [5] "How to Train Your Dragon"
## [6] "Despicable Me"
## [7] "Scott Pilgrim vs. the World"
## [8] "Hot Tub Time Machine"
## [9] "Harry Potter and the Deathly Hallows: Part 1"
## [10] "Tangled"
## [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [1] 8.8 6.5 7.8 8.4 8.2 7.7 7.5 6.5 7.7 7.9
## [1] "Notting Hill" "Eyes Wide Shut"
## [3] "The Green Mile" "10 Things I Hate About You"
## [5] "American Pie" "Girl, Interrupted"
## [7] "Leonardo DiCaprio" "Joseph Gordon-Levitt"
## [9] "Ellen Page" "Tom Hardy"
## [11] "Ken Watanabe"
## Plotting a part of the network
V(h1)$shape <- ifelse(V(h1)$type==TRUE,"square","circle")
V(h1)$shape[1:10]## [1] "square" "square" "square" "square" "square" "square" "square" "square"
## [9] "square" "square"
V(h1)$color <- ifelse(V(h1)$type==TRUE,"red","lightblue")
h2 <- subgraph.edges(h1, E(h1)[inc(V(h1)[name %in% c("The Wolf of Wall Street",
"Gangs of New York",
"The Departed")])])
plot(h2, layout = layout_with_kk)Mai departe este prezentata o analiza a actorilor, cu accent pe cei care au jucat in cele mai multe filme si cei care au jucat in cele mai apreciate filme
## [1] 0.001718711
##
## 1 2 3 4 5 6 7 8
## 955 165 47 23 11 2 1 1
## [1] 1.327801
## [1] "Leonardo DiCaprio" "Emma Watson" "Richard Griffiths"
## [4] "Harry Melling" "Daniel Radcliffe" "Rupert Grint"
## [7] "James Franco" "Ian McKellen" "Martin Freeman"
## [10] "Bradley Cooper" "Christian Bale" "Samuel L. Jackson"
## [13] "Natalie Portman" "Brad Pitt" "Liam Neeson"
busy_actor <- data.frame(cbind(Actor = V(h1)[type==FALSE & deg > 4]$name,
Movies = V(h1)[type==FALSE & deg > 4]$deg))
busy_actor[order(busy_actor$Movies,decreasing=TRUE),]## Actor Movies
## 5 Daniel Radcliffe 8
## 11 Christian Bale 7
## 1 Leonardo DiCaprio 6
## 2 Emma Watson 6
## 3 Richard Griffiths 5
## 4 Harry Melling 5
## 6 Rupert Grint 5
## 7 James Franco 5
## 8 Ian McKellen 5
## 9 Martin Freeman 5
## 10 Bradley Cooper 5
## 12 Samuel L. Jackson 5
## 13 Natalie Portman 5
## 14 Brad Pitt 5
## 15 Liam Neeson 5
## Displaying actors from best movies
for (i in 161:1365) {
V(h1)[i]$totrating <- sum(V(h1)[nei(i)]$IMDBrating)
}
max(V(h1)$totrating,na.rm=TRUE)## [1] 60.9
pop_actor <- data.frame(
cbind(Actor = V(h1)[type==FALSE & totrating > 40]$name,
Popularity = V(h1)[type==FALSE & totrating > 40]$totrating))
pop_actor[order(pop_actor$Popularity,decreasing=TRUE),]## Actor Popularity
## 3 Daniel Radcliffe 60.9
## 4 Christian Bale 55.5
## 1 Leonardo DiCaprio 49.6
## 2 Emma Watson 45
## 5 Brad Pitt 40.5
In plus, putem analiza si relatii de dependenta intre datele pe care le extragem. De exemplu, se poate face o regresie intre numarul de filme in care a jucat un actor si media scorului acestor filme, pentru a determina daca exista sau nu o legatura liniara intre acestea. Dupa cum se poate vedea in urma analizei urmatoare, precum si din afisarea grafica a rezultatelor, nu se poate extrage o astfel de legatura.
for (i in 161:1365) {
V(h1)[i]$avgrating <- mean(V(h1)[nei(i)]$IMDBrating)
}
num <- V(h1)[type==FALSE]$deg
avgpop <- V(h1)[type==FALSE]$avgrating
summary(lm(avgpop ~ num))##
## Call:
## lm(formula = avgpop ~ num)
##
## Residuals:
## Min 1Q Median 3Q Max
## -3.9858 -0.4330 0.1977 0.6170 1.6142
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 7.33868 0.05440 134.911 <2e-16 ***
## num 0.04714 0.03527 1.337 0.182
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.9605 on 1203 degrees of freedom
## Multiple R-squared: 0.001483, Adjusted R-squared: 0.0006528
## F-statistic: 1.786 on 1 and 1203 DF, p-value: 0.1816
scatter.smooth(num,avgpop,col="lightblue",ylim=c(2,10),span=.8,
xlab="Number of Movies",ylab="Avg. Popularity")In ultima parte a analizei, ne vom uita la proiectiile acestei retele, in particular la cea a filmelor. Iar la aceasta vom analiza mai multe statistici, pentru ca in final sa vizualizam reteaua formata din filmele care au in comun actori cu macar alte 5 filme, din care se poate observa ca fac partea cu preponderenta serii de filme precum: Star Wars, Harry Potter, The Hobbit, etc.
## Extract projections for the network
h1.pr <- bipartite.projection(h1)
h1.act <- h1.pr$proj1
h1.mov <- h1.pr$proj2
h1.act## IGRAPH cced947 UNW- 1205 6903 --
## + attr: name (v/c), year (v/n), IMDBrating (v/n), MPAArating (v/c),
## | shape (v/c), color (v/c), deg (v/n), totrating (v/n), avgrating
## | (v/n), weight (e/n)
## + edges from cced947 (vertex names):
## [1] Leonardo DiCaprio--Joseph Gordon-Levitt
## [2] Leonardo DiCaprio--Ellen Page
## [3] Leonardo DiCaprio--Tom Hardy
## [4] Leonardo DiCaprio--Ken Watanabe
## [5] Leonardo DiCaprio--Dileep Rao
## [6] Leonardo DiCaprio--Cillian Murphy
## + ... omitted several edges
## IGRAPH a67e1fa UNW- 160 472 --
## + attr: name (v/c), year (v/n), IMDBrating (v/n), MPAArating (v/c),
## | shape (v/c), color (v/c), deg (v/n), totrating (v/n), avgrating
## | (v/n), weight (e/n)
## + edges from a67e1fa (vertex names):
## [1] Inception--The Wolf of Wall Street Inception--Django Unchained
## [3] Inception--The Departed Inception--Gangs of New York
## [5] Inception--Catch Me If You Can Inception--The Dark Knight Rises
## [7] Inception--10 Things I Hate About You Inception--Batman Begins
## [9] Inception--The Dark Knight Inception--Training Day
## [11] Inception--Big Fish
## + ... omitted several edges
## Printing movie projection
op <- par(mar = rep(0, 4))
plot(h1.mov,vertex.color="red",vertex.shape="circle",
vertex.size=(V(h1.mov)$IMDBrating)-3,vertex.label=NA)## [1] 0.03710692
## [1] 12
## [1] 148 1 1 1 1 1 1 2 1 1 1 1
##
## 1 2 3 4 5 6 7 10
## 411 21 12 16 6 1 2 3
h2.mov <- induced.subgraph(h1.mov, vids=clusters(h1.mov)$membership==1)
plot(h2.mov,vertex.color="red",edge.width=sqrt(E(h1.mov)$weight),
vertex.shape="circle",vertex.size=(V(h2.mov)$IMDBrating)-3,vertex.label=NA)##
## 1 2 3 4 5 6 7
## 11 5 23 65 29 7 8
## Extracting and plotting only the nodes with coreness bigger than 4
h3.mov <- induced.subgraph(h2.mov,vids=graph.coreness(h2.mov)>4)
h3.mov## IGRAPH a59f5dc UNW- 44 158 --
## + attr: name (v/c), year (v/n), IMDBrating (v/n), MPAArating (v/c),
## | shape (v/c), color (v/c), deg (v/n), totrating (v/n), avgrating
## | (v/n), weight (e/n)
## + edges from a59f5dc (vertex names):
## [1] Alice in Wonderland --Hot Tub Time Machine
## [2] Hot Tub Time Machine --The Interview
## [3] The Hobbit: The Battle of the Five Armies--The Hobbit: The Desolation of Smaug
## [4] Inception --The Wolf of Wall Street
## [5] Exodus: Gods and Kings --American Hustle
## + ... omitted several edges
plot(h3.mov,vertex.color="red",vertex.shape="circle",
edge.width=sqrt(E(h1.mov)$weight),vertex.label.cex=0.7,
vertex.label.color="darkgreen",vertex.label.dist=0.3,
vertex.size=(V(h3.mov)$IMDBrating)-3)In analiza unei retele moderne sociale se desting urmatoarele caracterisici:
Este motivata de intelegerea intuitiva a structurii retelei bazata pe legaturile dintre actanti
Are la baza date empirice extrase intr-un mod sistematic
Se bazeaza foarte mult pe vizualizarea datelor utilizand metode grafice
Depinde de utilizarea modelelor matematice si computationale
Analizele prezentate pana in acest moment au pus accent pe primele trei concepte, iar in cele ce urmeaza il vom aborda pe cel din urma. Mai precis, vom incerca in continuare sa utilizam diferite modele pentru a genera o retea care sa aiba caracteristici similare cu reteaua initiala (cea a traficantilor).
O prima abordare luata in considerare, este propusa de Paul Erdos si Alfred Renyi. In aceasta metoda, reteaua este generata pornind de la un specificat de noduri si adaugand, in mod aleator, un numar specificat de muchii. Datorita acestei constructii, acest model este referit si sub denumirea de “random graph model”. Alternativ, pentru constructia unui astfel de model se poate specifica in locul numarului de muchii, o probabilitate de a avea muchie intre doua noduri ale retelei. In continuare, este prezentat codul pentru generarea retelei utilizand cele doua metode si vizualizarea grafica a rezultatelor comparativ cu reteaua initiala.
## Generate a similar network using Erdos-Renyi method (by specify the number of edges)
no_nodes <- length(V(inetsym))
no_edges <- length(E(inetsym))
er_net1 <- erdos.renyi.game(n=no_nodes,no_edges,type='gnm')
## Generate a similar network using Erdos-Renyi method (by specify the probability of having an edge between two nodes)
edge_prob <- no_edges / ((no_nodes-1)*no_nodes)
er_net2 <- erdos.renyi.game(n=no_nodes, edge_prob,type='gnp')
op <- par(mfrow=c(1,3))
plot(inetsym,vertex.label=NA,vertex.size=10)
plot(er_net1, vertex.label=NA, vertex.size=10)
plot(er_net2, vertex.label=NA, vertex.size=10)Modelul prezentat anterior este unul simplu de inteles, insa din cauza generalitatii sale, nu se pot genera retele care sa aiba anumite particularitati dorite (care sunt observate la o retea obtinuta empiric). Un astfel de exemplu, este faptul ca desi dimensiunile retelelor sociale pot fi de ordinul milionelor de noduri, diametrul acestora este considerabil mai mic, fapt ce nu este foarte usor de replicat in modelul anterior. De aceea modelul “Small-World” doreste sa imbunatateasca acest lucru pornind de la o configuratie prestabilita a muchiilor retelei, urmata de o modificarea a acestora cu o anumita probabilitate. Se poate observa ca folosind probabilitatea de modificare a muchiilor cu valoare 1, configuratia initiala nu va mai conta, iar modelul va fi similar cu cel prezentat anterior. Inainte de a prezenta codul pentru generarea acestui model, vom explica cum arata configuratia initiala a retelei. Nodurile sunt asezate in cerc, iar fiecare nod este legat de k dintre cei mai apropiati vecini ai sai (atat cei din dreapta, cat si cei din stanga). In exemplu urmator vom determina acest k, tinand cont de gradul mediu al unui nod, iar pentru probabilitatea de modificarea a unei muchii vom utiliza trei valori diferite ale parametrului (0.25, 0.5, 0.75). Analizand grafic cat de similare sunt aceste retele comparativ cu cea initiala.
## Generating a similar network using Small-World Model
avg_degree <- 2*no_edges/no_nodes
ws_net1 <- watts.strogatz.game(dim=1, size=no_nodes, nei=avg_degree/2, p=.25)
ws_net2 <- watts.strogatz.game(dim=1, size=no_nodes, nei=avg_degree/2, p=.5)
ws_net3 <- watts.strogatz.game(dim=1, size=no_nodes, nei=avg_degree/2, p=.75)
## Visualizing the results
op <- par(mfrow=c(2,2))
plot(inetsym,vertex.label=NA,vertex.size=10)
plot(ws_net1, vertex.label=NA, vertex.size=10)
plot(ws_net2, vertex.label=NA, vertex.size=10)
plot(ws_net3, vertex.label=NA, vertex.size=10)Din rezultatele grafice, se poate observa ca nici acest model nu este unul multumitor. In plus, o observatie importanta pentru cele doua modele este ca nici unul nu foloseste proprietati ale gradelor nodurilor din retea. Intr-o retea empirica, gradele nodurilor nu au o distributie apropiata de medie, existand multe noduri cu grad mic, dar si noduri cu grad considerabil mai mare decat medie (intr-o retea sociala, aceste noduri ar fi persoanele celebre din diferite domenii: actori, sportivi, politicieni, etc.). Aceasta problema este adresata in modelul de generare “Scale-Free” utilizat mai jos.
## Generate a similar network using Scale-Free Model
b_net <- barabasi.game(no_nodes, directed=FALSE)
## Visualize the result
op <- par(mfrow=c(1,2))
plot(inetsym,vertex.label=NA, vertex.size=10)
plot(b_net,vertex.label=NA, vertex.size=10)In finalul acestui capitol, sunt prezentate statistici comparative ale retelelor generate si rezultatele observate in cadrul retelei empirice.
## Comparing random models with the empirical network
list_network <- c(er_net1, ws_net2, b_net, inetsym)
comparison_table <- data.frame(
Name = c("Erdos-Renyi", "Small world", "Scale-free model", "Empiric network"),
Size = c(length(V(er_net1)), length(V(ws_net2)), length(V(b_net)), length(V(inetsym))),
Density = c(gden(asNetwork(er_net1)),gden(asNetwork(ws_net2)),gden(asNetwork(b_net)),gden(asNetwork(inetsym))),
Avg_Degree = c(length(E(er_net1))/length(V(er_net1)),length(E(ws_net2))/length(V(ws_net2)),length(E(b_net))/length(V(b_net)),length(E(inetsym))/length(V(inetsym))),
Transitivity = c(transitivity(er_net1), transitivity(ws_net2), transitivity(b_net), transitivity(inetsym)),
Isolates = c(sum(degree(er_net1)==0),sum(degree(ws_net2)==0),sum(degree(b_net)==0),sum(degree(inetsym)==0))
)
comparison_table## Name Size Density Avg_Degree Transitivity Isolates
## 1 Erdos-Renyi 21 0.1714286 1.714286 0.1666667 0
## 2 Small world 21 0.1000000 1.000000 0.0000000 2
## 3 Scale-free model 21 0.0952381 0.952381 0.0000000 0
## 4 Empiric network 21 0.1714286 1.714286 0.2500000 0